home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / numbers.em < prev    next >
Lisp/Scheme  |  1993-07-15  |  8KB  |  292 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: numbers.em
  4. ;; Date: Fri Dec  4 17:12:39 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule numbers
  11.   (extras0
  12.    macros0
  13.    init
  14.    )
  15.   ()
  16.   
  17.   (export lift-numbers min max lift e pi = abs zerop
  18.       positivep negativep evenp oddp
  19.       quotient remainder modulo)
  20.   ;;
  21.   ;; Simple functions
  22.   ;;
  23.  
  24.   (defun max (n1 . rest)
  25.     (labels ((check (max lst)
  26.             (if (null lst) max
  27.               (if (< max (car lst))
  28.               (check (car lst) (cdr lst))
  29.             (check max (cdr lst))))))
  30.         (check n1 rest)))
  31.  
  32.   (defun min (n1 . rest)
  33.     (labels ((check (min lst)
  34.             (if (null lst) min
  35.               (if (< (car lst) min)
  36.               (check (car lst) (cdr lst))
  37.             (check min (cdr lst))))))
  38.         (check n1 rest)))
  39.   
  40.   ;; 
  41.   ;; additional generics
  42.   ;;
  43.  
  44.   ;; abs
  45.   (defconstant abs (make <generic-function> 
  46.                 'lambda-list '(a)
  47.                 'argtype 1
  48.                 'name 'abs
  49.                 'method-class <method>))
  50.  
  51.   ;; zerop
  52.   
  53.   (defconstant zerop (make <generic-function> 
  54.                     'lambda-list '(a)
  55.                     'argtype 1
  56.                     'name 'zerop
  57.                     'method-class <method>))
  58.  
  59.   ;; Lift numbers
  60.   
  61.   (defconstant lift-numbers (make <generic-function>
  62.                        'lambda-list '(a b)
  63.                        'argtype 2
  64.                        'name 'lift-numbers
  65.                        'method-class <method>))
  66.   ;; elt functions...
  67.  
  68.  
  69.   ;; Float methods
  70.   (add-method binary+ (make <method> 
  71.                      'signature (list <double-float> <double-float>)
  72.                      'function binary+_Float))
  73.   (add-method binary- (make <method> 
  74.                 'signature (list <double-float> <double-float>)
  75.                      'function binary-_Float))
  76.   (add-method binary* (make <method> 
  77.                      'signature (list <double-float> <double-float>)
  78.                      'function binary*_Float))
  79.   (add-method binary/ (make <method> 
  80.                      'signature (list <double-float> <double-float>)
  81.                      'function binary/_Float))
  82.   (add-method binary< (make <method> 
  83.                      'signature (list <double-float> <double-float>)
  84.                      'function binary<_Float))
  85.  
  86.   (add-method = (make <method>
  87.               'signature (list <double-float> <double-float>)
  88.               'function binary=_Float))
  89.   
  90.   (add-method negate (make <method>
  91.                'signature (list <double-float>)
  92.                'function negate-float))
  93.  
  94.   ;; Number methods
  95.   
  96.   
  97.   (add-method binary+
  98.           (make <method> 'signature (list <number> <number>)
  99.                  'function 
  100.                  (method-lambda (x y)
  101.                         (lift binary+ x y))))
  102.   (add-method binary-
  103.           (make <method> 'signature (list <number> <number>)
  104.                  'function 
  105.                  (method-lambda ( x y)
  106.                         (lift binary- x y))))
  107.   (add-method binary*
  108.           (make <method> 'signature (list <number> <number>)
  109.                  'function 
  110.                  (method-lambda ( x y)
  111.                         (lift binary* x y))))
  112.   (add-method binary/
  113.           (make <method> 'signature (list <number> <number>)
  114.                  'function 
  115.                  (method-lambda ( x y)
  116.                         (lift binary/ x y))))
  117.   (add-method binary<
  118.           (make <method> 'signature (list <number> <number>)
  119.                  'function 
  120.                  (method-lambda ( x y)
  121.                         (lift binary< x y))))
  122.   (add-method =
  123.           (make <method> 'signature (list <number> <number>)
  124.                  'function 
  125.                  (method-lambda ( x y)
  126.                         (lift = x y))))
  127.   
  128.   (add-method lift-numbers
  129.           (make <method> 
  130.                  'signature (list <number> <number>)
  131.                  'function (method-lambda ( x y) nil)))
  132.  
  133.   (add-method lift-numbers (make <method> 
  134.                  'signature (list <fixint> <double-float>)
  135.                  'function (method-lambda ( x y) 
  136.                               <double-float>)))
  137.  
  138.   (defun lift (fn x y)
  139.     (let ((class (or (lift-numbers x y)
  140.              (lift-numbers y x)
  141.              (error "Can't lift numbers" <Internal-Error>
  142.                 'error-value (cons x y)))))
  143.       (add-method fn 
  144.           (make <method> 
  145.             'signature (list (class-of x) (class-of y))
  146.             'function (cond ((eq x class)
  147.                      (method-lambda (x y)
  148.                             (fn  x (convert y class))))
  149.                     ((eq y class)
  150.                      (method-lambda (x y)
  151.                             (fn (convert x class) y)))
  152.                     (t (method-lambda (x y)
  153.                               (fn (convert x class)
  154.                                   (convert y class)))))))
  155.       (fn (convert x class)
  156.       (convert y class))))
  157.  
  158.  
  159.   ;; Elt. Functions
  160.   
  161.   (define-simple-generic sin (<double-float>) sin-float)
  162.   (define-simple-generic cos (<double-float>) cos-float)
  163.   (define-simple-generic tan (<double-float>) tan-float)
  164.   (define-simple-generic asin (<double-float>) asin-float)
  165.   (define-simple-generic acos (<double-float>) acos-float)
  166.   (define-simple-generic atan (<double-float>) atan-float)
  167.   (define-simple-generic log (<double-float>) log-float)
  168.   (define-simple-generic log10 (<double-float>) log10-float)
  169.   (define-simple-generic sqrt (<double-float>) sqrt-float)
  170.   (define-simple-generic exp (<double-float>) exp-float)
  171.   (define-simple-generic sinh (<double-float>) sinh-float)
  172.   (define-simple-generic cosh (<double-float>) cosh-float)
  173.   (define-simple-generic tanh (<double-float>) tanh-float)
  174.   (define-simple-generic asinh (<double-float>) asinh-float)
  175.   (define-simple-generic acosh (<double-float>) acosh-float)
  176.   (define-simple-generic round (<double-float>) round-float)
  177.   (define-simple-generic floor (<double-float>) floor-float)
  178.   (define-simple-generic ceiling (<double-float>) ceiling-float)
  179.  
  180.   ;; XXX: Bugs
  181.   ;; constants
  182.   (defconstant zero 0)
  183.   (defconstant e (exp 1.0))
  184.   (defconstant pi (* 2.0 (asin 1.0)))
  185.   
  186.   (defconstant true-pred
  187.     (method-lambda (x) t))
  188.  
  189.   (defconstant false-pred
  190.     (method-lambda (x) nil))
  191.  
  192.   ;; floatp
  193.   (define-simple-generic floatp (<double-float>) true-pred)
  194.   (add-method floatp (make <method> 
  195.                'signature (list <object>) 
  196.                'function false-pred))
  197.   ;; numberp
  198.   (define-simple-generic numberp (<number>) true-pred)
  199.   (add-method numberp (make <method>
  200.                 'signature (list <object>) 
  201.                 'function false-pred))
  202.  
  203.   ;; integerp
  204.   (define-simple-generic integerp (<integer>) true-pred)
  205.   (add-method integerp (make <method>
  206.                  'signature (list <object>) 
  207.                  'function false-pred))
  208.   
  209.   ;; equal
  210.  
  211.   (add-method equal (make <method> 
  212.                    'signature (list <number> <number>)
  213.                    'function (method-lambda ( a b) (= a b))))
  214.  
  215.   
  216.   ;; positivep
  217.   ;; Should be generic...
  218.   (defun positivep (x)
  219.     (< 0 x))
  220.   
  221.   ;; negativep
  222.   (defun negativep (x)
  223.     (< x 0))
  224.   
  225.   ;; zerop 
  226.   (add-method zerop
  227.           (make <method> 
  228.             'signature (list <number>)
  229.             'function (method-lambda (c)
  230.                          (= c zero))))
  231.   
  232.   (add-method zerop
  233.           (make <method> 'signature (list <fixint>)
  234.             'function (method-lambda (c)
  235.                          (eq c zero))))
  236.  
  237.   ;; evenp
  238.   (defun evenp (x)
  239.     (zerop (remainder x 2)))
  240.  
  241.   ;; oddp
  242.   (defun oddp (x)
  243.     (not (evenp x)))
  244.  
  245.   ;; quotient
  246.   (define-simple-generic quotient (<fixint> <fixint>) quotient-integer)
  247.   
  248.   ;; XX: There is a difference (sign) between mod and remainder.
  249.   ;;     Would someone fill the details in...
  250.  
  251.   ;;remainder 
  252.   (define-simple-generic remainder (<fixint> <fixint>) remainder-integer)
  253.  
  254.   ;;modulo
  255.   (define-simple-generic modulo (<fixint> <fixint>) modulo-integer)
  256.  
  257.   (add-method quotient (make <method>
  258.                  'signature (list <number> <number>)
  259.                  'function (method-lambda ( x y)
  260.                               (lift quotient x y))))
  261.   (add-method remainder (make <method>
  262.                        'signature (list <number> <number>)
  263.                        'function (method-lambda (x y)
  264.                                 (lift remainder x y))))
  265.  
  266.   ;;convert float->int.
  267.  
  268.   ;; convert int-> float
  269.   (add-method (converter <double-float>)
  270.           (make <method> 
  271.             'signature (list <integer>)
  272.             'function convert-integer-float))
  273.  
  274.  
  275.   ;; abs 
  276.   
  277.   (add-method abs 
  278.           (make <method> 
  279.                  'signature (list <number>)
  280.                  'function
  281.                  (method-lambda (c)
  282.                    (if (positivep c) c
  283.                  (negate c)))))
  284.  
  285.   
  286.   ;; truncate
  287.  
  288.   ;; round
  289.  
  290.   ;; end module
  291.   )
  292.